{-# LANGUAGE EmptyDataDecls, MultiParamTypeClasses, FunctionalDependencies, RankNTypes, FlexibleInstances, TypeFamilies, GeneralizedNewtypeDeriving, FlexibleContexts, ExistentialQuantification, RecordWildCards, ScopedTypeVariables #-}

--todo: miniIO

module Main () where

import Sound.PortMidi -- cabal install PortMidi
import qualified Data.Traversable as T (sequenceA,mapM)
import Control.Arrow
import Control.Monad
import Control.Applicative
import System.Random
import qualified Data.Heap as H -- cabal install heap
import Control.Concurrent
import Control.Monad.Reader
import Control.Monad.Writer
import Control.Monad.State
import Control.Monad.Identity
import Data.Maybe
import Data.List

-- default () -- there are some annoying numeric class problems that prevent us from being polymorphic in latencyMS, myLatMS, tempo, calcDurMS and drain

-- *configuration

latencyMS     = 1 -- must be > 0, or portmidi ignores timestamps
myLatMS       = 1 -- the latency of our scheduler (events need to be added this far ahead of time in order to be output in order, otherwise they will just be emitted immediately)
measuresAhead = 2 -- how far ahead of the output the composer stays

tempo     = 200 -- bpm
timeSig   = TimeSig { numBeats = 4
                    , unit     = Quarter
                    }

intervals = [2,1,2,2,1,2,2]; -- minor scale

-- *the composition algorithm

numMeasures = 8
noteRange = (-20,20)

-- need to augment this with StateT so can refer to history
composeMeasure :: (MonadSupply Int m, Integral a) => a -> m [Note]
composeMeasure mn =
    mapM replaceNoteNum notes
    where measureNum = fromIntegral mn 
	  notes = if measureNum == numMeasures
                     then [downbeat]
                     else [n {beat = b} | n <- [downbeat, changeDur downbeat {vel = 100, subdiv = 2/3} (Triplet Eighth)] -- need changeDur to avoid "Record update for insufficiently polymorphic field"; dur is existential
                                        , b <- [0 .. numBeats timeSig - 1]
                                        ]
-- http://www.haskell.org/ghc/docs/6.12-latest/html/users_guide/release-6-12-1.html#id2887987
-- Record updates can now be used with datatypes containing existential type variables, provided the fields being altered do not mention the existential types.
          changeDur :: (NoteDur b) => Note -> b -> Note -- would rather use existential record update syntax, but dur is existential
          changeDur Note{..} d = Note {
                midiNum = midiNum
              , vel     = vel
              , chan    = chan
              , measure = measure
              , beat    = beat
              , subdiv  = subdiv -- realToFrac s
              , dur     = d
              }
          downbeat = Note { midiNum = 60
                          , vel     = 75
                          , chan    = 0
                          , measure = fromIntegral measureNum
                          , beat    = 0
                          , subdiv  = 0
                          , dur     = Triplet Quarter
                          }
          replaceNoteNum x = do
	    (Just o) <- untilM ((/= 0) . fromJust) (const $ (fmap signum) <$> snext) $ Just 0
	    (Just m) <- snext
            let nr :: (Real r) => (Note -> r) -> (Note -> Rational)
                nr = (toRational .)
                interval = getInterval (if measureNum == numMeasures 
			                   then 0 
					   else m + if odd (mod m $ length intervals) && (and . map (== 0) $ [nr beat, nr subdiv] <*> [x]) -- see discussion of why not to use existentials here http://tunes.org/~nef//logs/haskell/09.08.12
						       then o -- on first beat of each measure play a chord tone
					               else 0
				       ) intervals
            return $ x {midiNum = midiNum x + interval}

-- *midi/music util

getInterval :: Int -> [Int] -> Int
getInterval n is 
	| n >= 0    = d * (last s) + if m == 0 
					then 0 
				  	else s !! (m-1)
	| otherwise = getInterval (-n) . map (* (-1)) $ reverse is -- could avoid this reverse with some fold fu
	where (d,m) = divMod n $ length is
              s     = cumsum is

-- less efficient but more fun!
getInterval' :: Int -> [Int] -> Int
getInterval' n is = m
    where keys     = 0 : interleave [[1..], [-1,-2..]]
          vals     =     interleave [lower, higher]
          higher   = scanl1 (+)   $ cycle           is
          lower    = scanl  (-) 0 $ cycle $ reverse is
          (Just m) = lookup n $ zip keys vals

compose :: LoggerT (CtxtRdrT IO) ()
compose = do
    join . liftIO . runRandomRIOT noteRange $ mapM_ makeNotes [0 .. numMeasures]
    tell ["done making notes"]

makeNotes :: (Integral a) => a -> SupT (LoggerT (CtxtRdrT IO)) ()
makeNotes thisMeasureNum = do
    m <- lift $ asks measureNum
    untilM ((measuresAhead >=) . ((fromIntegral thisMeasureNum) -)) 
	   (const . liftIO $ (threadDelay . round $ 1000 * measureMS/2) >> readMVar m) -- throttle the composing or else the queue gets big and slow
	   0
    liftIO . putStrLn $ "composing measure " ++ show thisMeasureNum
    -- tell ["making notes for measure " ++ show thisMeasureNum]
    lift . lift . addNotes =<< composeMeasure thisMeasureNum

addNotes :: [Note] -> CtxtRdrT IO ()
addNotes = mapM_ addNote

-- because a noteOff event in midi turns off a note no matter how many previous noteOns occurred, 
-- we need to be careful to not schedule a noteOff during a previously scheduled note, and remove 
-- any previously scheduled noteOff that would prematurely cut off the new note.  the alg is a little 
-- tricky and it would be nice to "prove" its correctness -- and there are enough degrees of freedom 
-- that QuickCheck would not explore the relevant corner cases.  how would one approach this from a 
-- curry-howard perspective?  i think the invariant is that there are never two noteOffs in a row.
-- also, any way to decompose this better?
addNote :: Note -> CtxtRdrT IO ()
addNote n = do
    t <- asks startTime

    let start      = PMEvent { message   = noteOn
                             , timestamp = startT
                             }
        end        = PMEvent { message   = noteOff
                             , timestamp = endT
                             }
        startT     = t + (round $ calcStartMS n)
	endT       = startT + (round $ calcDurMS n)
	unInt      = fromInteger . fromIntegral
        noteOn     = PMMsg { status = unInt $ onCode + chan n
                           , data1  = unInt $ midiNum n
                           , data2  = unInt $ vel n
                           }
        noteOff    = noteOn {data2 = 0}
	onCode     = 0x90
	maybeEnd q = if overlap . span ((endT >) . timestamp) . H.toAscList . fst $ H.partition match q -- break the schedule of events with the same midiNum and channel into (before endT,same time as or after endT)
		     	then []                                                       -- we don't add a noteoff when it occurs during a previously existing note
		     	else [end] 
        match      = (\m -> data1 m == (unInt $ midiNum n)                            -- find events with the same midiNum and channel -- how avoid calculating this twice for each element 
										      -- (once in the partition and once in the filter)?
			     && 
			    (status m) - unInt onCode == (unInt $ chan n)
		     ) . message 
	isNoteOff  = (0 ==) . data2 . message
	notDuring  = or . ([(endT <=),(startT >)] <*>) . return . timestamp           -- remove any previously existing noteOff that will occur after startT and before (or simultaneous with) endT
		      &&& 
		     not . and . ([match, isNoteOff] <*>) . return                    -- only noteOffs for the matching midiNum and channel can be filtered out
		      >>^ uncurry (||)
	overlap    = fromMaybe False . fmap (not . isNoteOff) . maybeLast             -- we do not schedule a noteOff if the first thing before us is a noteOn
		      ***
		     or . catMaybes . (([fmap] <*> [isNoteOff,(endT ==) . timestamp]) <*>) . return . maybeHead -- or if the first thing after us is a noteOff (implying we overlapped with an ongoing note) 
		      >>^ uncurry (||)										-- note we fail to return to the original velocity.  also omit our noteOff if a noteOn or noteOff 
														-- was already scheduled at the same time.  there is one failure condition 
														-- when there is nothing before us and a noteOn after us, there may be a note currently playing 
														-- and we've missed its noteOn (we assume this isn't the case; to fix, we'd have to keep a 
														-- synchronized list of currently playing notes, each with a stack of their velocities)
		      
    when (startT < endT) $ asksTo modifyMVar_ queue $ \q -> return
							    $ foldl (flip H.insert) (H.filter notDuring q) -- not sure the foldl is wise, especially since insert looks designed for foldr, but we know we're 
													   -- dealing with a finite list...
							    $ start : maybeEnd q      -- would it be more efficient to insert in a different order?

calcStartMS :: (Real a, Fractional a) => Note -> a
calcStartMS n = realToFrac $ ((subdiv n) + (fromIntegral ((measure n) * (numBeats timeSig) + (beat n)))) * (calcDurMS $ unit timeSig)

measureMS :: (Real a, Fractional a) => a
measureMS = calcStartMS Note { measure = 1
			     , beat    = 0
			     , subdiv  = 0
			     , midiNum = undefined
                             , vel     = undefined
                             , chan    = undefined
                             , dur     = undefined :: DurBase -- ugh
                             }

data Note = forall x . NoteDur x => Note {
      midiNum :: Int -- 0-255
    , vel     :: Int -- 0-255
    , chan    :: Int -- 0-15
    , measure :: Integral a => a
    , beat    :: Int
    , subdiv  :: (Real a, Fractional a) => a -- % of beat
    , dur     :: x
    }

data DurBase = Whole | Half | Quarter | Eighth | Sixteenth | ThirtySecond deriving (Enum, Bounded, Show, Eq)
data ModDur = forall x. NoteDur x => Dotted x | Triplet DurBase

class NoteDur a where
    quarters :: (Real x, Fractional x) => a -> x 
     
    calcDurMS :: (Real x, Fractional x) => a -> x
    calcDurMS d = 1000 * 60 * (beats d) / (realToFrac tempo)

    beats :: (Real x, Fractional x) => a -> x   
--    beats d = (quarters d) / (quarters $ unit timeSig) -- want to factor out the application of quarters
--    beats d = uncurry (/) $ join (***) quarters (d, unit timeSig) -- join (***) from Saizan_ @ #haskell, but isn't existentially polymorphic
    beats d = uncurry (/) $ both quarters (d, unit timeSig)
	where both (f :: forall a b. (NoteDur a, Real b, Fractional b) => a -> b) (x, y) = (f x, f y) -- lame that this has to be class specific (copumpkin @ #haskell says a 'forall classes' would be nice)

instance NoteDur DurBase where
    quarters x = z where Just z = lookup x $ zip [minBound .. maxBound] $ map (fromRational . (2 ^^)) [2, 1 ..]

instance NoteDur ModDur where
{- why isn't something like this OK?  scree @ #haskell points out that if NoteDur were a type instead of a class it would work, but then we have to carry around another constructor (ie: NoteDur Dotted Eighth)
    quarters (x y) = quarters y * case x of
	Dotted  -> 3 / 2
    	Triplet -> 2 / 3
-}
    quarters (Dotted  x) = quarters x * 3 / 2
    quarters (Triplet x) = quarters x * 2 / 3

instance NoteDur Note where
     quarters Note{..} = quarters dur

data TimeSig = TimeSig {
      numBeats :: Int
    , unit     :: DurBase
    }

-- *our scheduler ensures we send monotonic increasing timestamps to portmidi

-- igel @ #haskell (Data.Heap's author) agrees there's no way to reuse MinPolicy here -- HeapItem MinPolicy a is already defined for all a
-- edward says it might have been possible for him to use a class that would let us override it
data PMPol
instance H.HeapItem PMPol PMEvent where
    newtype H.Prio PMPol PMEvent = PMP (Integer,Integer) deriving (Eq, Ord) -- velocity is 2nd component of ordering so noteoffs happen before noteons
    type    H.Val  PMPol PMEvent = PMMsg

    split x = ( PMP ( fromIntegral $ timestamp x
                    , fromIntegral . data2 $ message x
                    )
              , message x
              )
    merge (PMP x,y) = PMEvent { timestamp = fromIntegral $ fst x
                              , message   = y
                              }

type PMQ = H.Heap PMPol PMEvent

-- any way to decompose this better?
drain :: (Bool, [String]) -> LoggerT (CtxtRdrT IO) Bool
drain (_,prevLog) = do
    tell prevLog
    s  <- asks stream
    t  <- liftIO time
    st <- asks startTime

    let m    = (fromIntegral (t - st)) / measureMS
	done = m >= (fromIntegral numMeasures)
	cleanup nq str del next = return (nq, (str, next, del, done && H.null nq))

    asks measureNum >>= liftIO . flip modifyMVar_ (const $ return m)

    (str, next, del, out) <- lift . asksTo modifyMVar queue $ \q ->

        case H.view q of
            Nothing          -> cleanup q "q empty" (not done) Nothing
            Just (next,rest) -> do
		e <- liftIO $ useStream hasHostError (const $ return True) s
                if ts <= myLatMS + t || fromMaybe True e
                   then cleanup rest rpt False $ Just next
                   else cleanup q    ""  True    Nothing
                where ts  = timestamp next
                      rpt =    "\nmeasure: "
			    ++ (take 8 $ (show m) ++ (repeat ' '))
			    ++ "   \tevent timestamp: "
                            ++ (show ts)
                            ++ "   \tvel: "
                            ++ (show . data2 $ message next)
                            ++ "   \t("
                            ++ (show $ H.size rest)
                            ++ " events remaining) "

    tell [str]
    T.mapM doEvent next
    when del $ tell ["."] >> liftIO (threadDelay . round $ 1000 * toRational myLatMS) -- threadDealy's resolution looks to be 10ms, seems very large?
    return out

doEvent :: PMEvent -> LoggerT (CtxtRdrT IO) ()
doEvent e = do
    s <- asks stream
    mapWriterT lift $ showResult (useStream (flip writeEvents [e]) return s) ("writing event... " ++)

-- *util

-- adapted from http://www.haskell.org/haskellwiki/New_monads/MonadSupply
-- hides implementation, handles finite supplies, includes function to get multiple items
-- much taken from RWH's Supply monad in ch. 15: http://book.realworldhaskell.org/read/programming-with-monads.html#id646649
-- transformer in ch. 18: http://book.realworldhaskell.org/read/monad-transformers.html#monadtrans.maybet

newtype SupplyT s m a = ST (StateT [s] m a) deriving (Functor, Monad, MonadTrans, MonadIO)
newtype Supply s a = S (SupplyT s Identity a) deriving (Monad, Functor, MonadSupply s)

class (Monad m, Functor m) => MonadSupply s m | m -> s where
    snext  :: m (Maybe s)
    snext  =  head <$> snexts 1
    snexts,snexts' :: Integral a => a -> m [Maybe s]

instance (Monad m, Functor m) => MonadSupply s (SupplyT s m) where
    snexts n = ST $ do -- blackh @ #haskell's solution, cleaner than my Kleislis
	(these,rest) <- genericSplitAt n <$> get
	put rest
	return . genericTake n $ map Just these ++ repeat Nothing
    snexts' n = ST $ genericSplitAt n <$> get >>=
		        runKleisli (fst ^<< Kleisli (return . genericTake n . (++ repeat Nothing) . map Just)
		 	                     *** 
			 	            Kleisli put) -- put requires that we Kleisli, because it is s -> m()

runSupply :: Supply s a -> [s] -> (a, [s])
runSupply (S m) = runIdentity . runSupplyT m

runSupplyT :: Functor m => SupplyT s m a -> [s] -> m (a, [s])
runSupplyT (ST s) = runStateT s

evalSupply :: Supply s a -> [s] -> a
evalSupply (S s) = runIdentity . evalSupplyT s

evalSupplyT :: (Functor m) => SupplyT s m a -> [s] -> m a
evalSupplyT = fmap fst `dot` runSupplyT

randomsRIO :: Random a => (a,a) -> IO [a] -- note System.Random is known to be very slow, but this application isn't very demanding (see discussion here, incl pointers to nonuniform distributions: http://www.serpentine.com/blog/2009/09/19/a-new-pseudo-random-number-generator-for-haskell/)
randomsRIO lims = getStdRandom $ first (randomRs lims) . split

runRandomRIO :: (Random s) => (s, s) -> Supply s a -> IO a
runRandomRIO r s = fmap (evalSupply s) $ randomsRIO r

runRandomRIOT :: (Functor m, Random s) => (s, s) -> SupplyT s m a -> IO (m a)
runRandomRIOT r s = fmap (evalSupplyT s) $ randomsRIO r

--

-- same as listToMaybe
maybeHead :: [a] -> Maybe a
maybeHead = find $ const True

maybeLast :: [a] -> Maybe a
maybeLast [] = Nothing
maybeLast x  = Just $ last x

cumsum :: Num a => [a] -> [a]
cumsum = scanl1 (+)

interleave :: [[x]] -> [x]
interleave = fix $ \f x -> (map head x) ++ f (map tail x)

lcat :: [[a]] -> [[a]]
lcat = (: []) . concat

-- from http://www.haskell.org/haskellwiki/Pointfree#Dot
-- note (f `dot` g) x = f . g x (http://stackoverflow.com/questions/907306/confusion-about-currying-and-point-free-style-in-haskell)
dot :: (c -> d) -> (a -> b -> c) -> a -> b -> d
dot = (.) . (.)

-- from http://www.haskell.org/pipermail/beginners/2009-January/000690.html (via byorgey @ #haskell)
untilM :: (Monad m) => (a -> Bool) -> (a -> m a) -> a -> m a
untilM p f x | p x       = return x
             | otherwise = f x >>= untilM p f

-- from ski @ #haskell (see http://tunes.org/~nef//logs/haskell/09.08.06)
-- avoids nesting liftIO's, which gives a compiler error, when one wants more than one MVar from a ReaderT simultaneously using form:
-- asks selector >>= liftIO . (flip xxxMVar) (\x ->
asksTo :: (Monad m) => (a -> (a3 -> m1 a2) -> m a1) -> (r -> a) -> (a3 -> ReaderT r m1 a2) -> ReaderT r m a1
asksTo wrap sel body = do
    mv <- asks sel
    ReaderT $ \r ->
        wrap mv $ (`runReaderT` r) . body

{-
asksTo isn't as polymorphic as we'd like -- it only works for ReaderT's instead of all MonadReader's
to get more polymorphic, ski was thinking about:

dig :: (forall f m. (Functor f,Monad m) => ReaderT R m (f a) -> ReaderT R m (f b)) -> (Foo a -> Foo b)

newtype Foo a = MkFoo {unFoo :: ReaderT Context IO a}

digIO :: (forall f. Functor f => IO (f a) -> IO (f b)) -> (Foo a -> Foo b)
digIO grovel ma = MkFoo (liftM runIdentity (grovel (liftM Identity (unFoo ma))))

asksToIO :: MonadReader r Foo => (a -> (b -> IO o) -> IO p) -> (r -> a) -> (b -> Foo o) -> Foo p
-}

{- previous attempt doesn't nest cuz of liftIO, but is more polymorphic
asksTo' :: (MonadReader r m, MonadIO m) => (a -> t -> IO b) -> (r -> a) -> t -> m b
asksTo' wrap sel body = do
    mv <- asks sel
    liftIO (wrap mv body)
-}

{-
see this from quicksilver for a general method that may apply:
http://www.haskell.org/pipermail/haskell-cafe/2007-July/028501.html

also this may help, or could at least get rid of all the layers of lift:
http://blog.sigfpe.com/2010/02/tagging-monad-transformer-layers.html
-}

{-
newtype MiniIO a = MiniIO { runMiniIO :: IO a }
    deriving (Monad) -- don't derive MonadIO cuz the point is to prevent arbitrary IO

class Monad m => MonadMiniIO m where
    writeEvents  :: PMStream -> [PMEvent] -> IO PMError
    time         :: IO Sound.PortMidi.Timestamp
    threadDelay  :: Int -> IO ()
    modifyMVar   :: forall a b. MVar a -> (a -> IO (a, b)) -> IO b
    modifyMVar_  :: forall a. MVar a -> (a -> IO a) -> IO ()
    withMVar     :: forall a b. MVar a -> (a -> IO b) -> IO b
    getStdRandom :: forall a. (StdGen -> (a, StdGen)) -> IO a

instance MonadMiniIO miniIO where
    writeEvents  = Sound.PortMidi.writeEvets
    time         = Sound.PortMidi.time
    threadDelay  = Control.Concurrent.threadDelay
    modifyMVar   = Control.Concurrent.MVar.modifyMVar
    modifyMVar_  = Control.Concurrent.MVar.modifyMVar_
    withMVar     = Control.Concurrent.MVar.withMVar
    getStdRandom = System.Random.getStdRandom
-}

data Context = Context {
      measureNum    :: MVar Double -- why does the following fail? (Real a, Fractional a) => MVar a
    , queue         :: MVar PMQ
    , stream        :: Maybe (Either PMStream PMError)
    , startTime     :: Real a => a
    }

type CtxtRdrT = ReaderT Context
type LoggerT = WriterT [String] -- note []'s have slow (++) http://book.realworldhaskell.org/read/programming-with-monads.html#monadcase.writer.dlist
type SupT = SupplyT Int

printLog :: String -> ([String] -> [String]) -> IO ([String]) -> IO ()
printLog logName f = (putStr =<<) . fmap (unlines . (["\n\n" ++ logName ++ " Log:"] ++) . f)

showResult :: Show a => (IO a) -> (String -> String) -> LoggerT IO ()
showResult f g = tell =<< (fmap ((: []) . g . show) $ liftIO f)

doError :: PMError -> IO PMError
doError x = putStr "\n***" >> getErrorText x >>= putStrLn >> return x

useStream :: (PMStream -> IO a) -> (b -> IO a) -> Maybe (Either PMStream b) -> IO (Maybe a)
useStream = T.sequenceA `dot` fmap `dot` (|||)

-- *main

main :: IO ()
main = printLog "PortMidi" id $ execWriterT main'

main' :: LoggerT IO ()
main' = do
    showResult initialize ("initializing... " ++)

    showResult countDevices $ ("found " ++) . (++ " devices")

    d <- liftIO getDefaultOutputDeviceID
    showResult (T.mapM getDeviceInfo d) (("default output is " ++ show d ++ ": ") ++)

    s <- liftIO $ T.mapM (flip openOutput latencyMS) d
    tell ["opening stream... " ++ show s]

    t <- liftIO time -- must be evaluated after opening stream, which resets the counter!  portmidi.h says:
                     -- "If the application wants to use PortTime, it should start the timer (call Pt_Start) before calling Pm_OpenInput or Pm_OpenOutput."
                     -- but PortMidi.hs neither exposes Pt_Start nor calls it

    q <- liftIO $ newMVar (H.empty :: PMQ)
    m <- liftIO $ newMVar $ realToFrac 0

    let inContext = flip runReaderT Context {measureNum = m, queue = q, stream = s, startTime = fromIntegral t}

    liftIO . forkIO . printLog "Composer" id . inContext $ execWriterT compose

    drainLog <- fmap snd $ liftIO $ untilM fst (inContext . runWriterT . drain) (False,[]) -- consider forking the consumer too (http://www.haskell.org/haskellwiki/Performance/Concurrency), 
											   -- tho this forces us to listen for it to finish -- how eliminate all main/fork communication?
    -- stick a manual join (with an MVar) right here to guarantee the drain log doesn't dump to stdio simultaneously with the composer log
    liftIO . printLog "Drain" lcat $ return drainLog

    e <- liftIO $ useStream hasHostError (const $ return False) s
    when (fromMaybe False e) $ tell ["\n***PortMidi host error"] -- PortMidi.hs doesn't expose Pm_GetHostErrorText()

    showResult (useStream close doError s) ("closing stream... " ++)

    showResult terminate $ ("terminating... " ++) . (++ "\ndone")
